Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/MacGofer 0.22d/MacGofer Sources/twospace.c

C/C++ Source or Header | 1994-01-06 | 5.0 KB | 169 lines | [TEXT/MPS ]

/* --------------------------------------------------------------------------
 * twospace.c:  Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
 *              See goferite.h for details and conditions of use etc...
 *              Gofer version 2.28 January 1993
 *
 * Two space copying GC, optionally used for gofc runtime system.
 * ------------------------------------------------------------------------*/

/* --------------------------------------------------------------------------
 * Simple twospace copying collector:
 * ------------------------------------------------------------------------*/

static Void   heapInit        Args((Void));
static Void   markPhase        Args((Void));
static Cell   forward        Args((Cell));
static Cell   copyCell        Args((Cell));

Int     heapSize = DEFAULTHEAP;        /* number of cells in heap       */
static  Heap space1,space2;        /* the two heap spaces           */
#ifndef GLOBALcar
Heap    from;                /* (top of) current from space       */
#endif
static  Heap to;            /* (top of) current to space       */
#ifndef GLOBALcdr
Cell    hp;                /* current heap pointer           */
#endif
static  Bool fileUsed[NUM_FILES];    /* file in use flags           */
#define mark(c)  c=forward(c)        /* mark graph and save new pointer */

static Void heapInit() {        /* initialise heap storage       */
    space1 = (Heap)(farCalloc(heapSize,sizeof(Cell)));
    space2 = (Heap)(farCalloc(heapSize,sizeof(Cell)));
    if (space1==(Heap)0 || space2==(Heap)0)
    abandon("Cannot allocate heap storage");
    from = space1 + heapSize;
    to   = space2 + heapSize;
    hp   = -heapSize-1;
}

#if  !INLINE_ALLOC            /* allocation (not inlined) gives  */
Cell pair(l,r)                /* smaller object code size, but   */
Cell l,r; {                /* with a small hit on speed.       */
    from[++hp] = l;
    from[++hp] = r;
    return (hp-1);
}
#endif

Void garbageCollect() {            /* garbage collector           */
    register Cell toIn = -heapSize-1;
    Heap swap;
    Int  i;
    hp = toIn;

    for (i=0; i<NUM_FILES; ++i)        /* assume all files need collection*/
    fileUsed[i] = FALSE;

    markPhase();            /* mark all cells in use       */

    while (toIn<hp) {            /* use tospace as a queue to copy  */
    Cell tag = to[++toIn];        /* the whole graph currently in use*/

    if (isPair(tag)) {        /* must be application node       */
        to[toIn] = forward(tag);
        ++toIn;            /* to another cell           */
        to[toIn] = forward(to[toIn]);
    }
        else if (tag>MAXBOXTAG) {    /* application of unboxed value       */
        ++toIn;            /* to another cell           */
        to[toIn] = forward(to[toIn]);
    }
    else                /* tagged cell - value already       */
        ++toIn;            /*          copied across       */
    }
    if (hp+1000>=0)
    abandon("Garbage collection fails to reclaim sufficient space");

    for (i=0; i<NUM_FILES; ++i)        /* close all files no longer in use*/
    if (!fileUsed[i])
        closeFile(i);

    swap = from;            /* exchange tospace and fromspace  */
    from = to;
    to   = swap;
}

static Void markPhase() {        /* mark phase of garbage collector */
    StackPtr sp1;
    Int         i;

    stackLoop(sp1)            /* mark nodes on stack           */
    mark(*sp1);
    for (i=0; i<num_scs; i++)        /* mark supercombinator nodes       */
    mark(sc[i]);
    for (i=0; i<num_cdicts; i++)        /* mark dictionary entries       */
    mark(dict[i]);
    for (i=0; i<NUM_CHARS; ++i)        /* mark character conses       */
    mark(consCharArray[i]);
    mark(resps);            /* mark responses           */
    primMark();                /* mark primitives           */
}

static Cell forward(c)            /* find forwarding location of cell*/
Cell c; {
    if (isPair(c)) {            /* only pairs need be forwarded       */
    Cell tag = fst(c);
    if (tag==INDIRECT) {        /* short out indirection nodes       */
        Cell back = mkCfun(0);
        do {
        fst(c) = INDIRECT1;
        tag    = snd(c);
        snd(c) = back;
        back   = c;
        c      = tag;
        if (!isPair(c))
            break;
        tag    = fst(c);
        } while (tag==INDIRECT);

        if (isPair(c)) {        /* a specialised form of forward() */
        if (tag==INDIRECT1)
            c = primBlackHole;
        else if (tag==FORWARD)
            c = snd(c);
        else {
            if (tag==FILECELL)
            fileUsed[snd(c)] = TRUE;
            c = copyCell(c);
        }
        }

        while (isPair(back)) {    /* update all indirections       */
        tag      = snd(back);
        fst(back) = FORWARD;
        snd(back) = c;
        back      = tag;
        }
        return c;
    }
    else if (tag==FORWARD)        /* previously forwarded cell       */
        return snd(c);
    else {                /* pair to be forwarded           */
        if (tag==FILECELL)
        fileUsed[snd(c)] = TRUE;
        return copyCell(c);
    }
    }
    return c;
}

static Cell copyCell(c)            /* copy pair fromspace --> tospace */
Cell c; {
#if SMALL_GOFER
    to[++hp]  = from[c];        /* not worth the trouble of a reg  */
    from[c]   = FORWARD;        /* assignment for far pointers       */
    to[++hp]  = from[c+1];
    from[c+1] = hp-1;
    return hp-1;
#else
    register Cell *fp = from+c;
    to[++hp] = *fp;            /* don't need to check for heap       */
    *fp++    = FORWARD;            /* overflow since no halfspace can */
    to[++hp] = *fp;            /* be bigger that the other!       */
    return (*fp = hp-1);
#endif
}

/*-------------------------------------------------------------------------*/